home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / KERNEL1.SEQ < prev    next >
Text File  |  1988-06-30  |  29KB  |  927 lines
  1. \ KERNEL1.SEQ  Source code for KERNEL1.COM,   modified by Tom Zimmer
  2.  
  3. ONLY FORTH   META ALSO FORTH
  4.  
  5. FALSE   CONSTANT INLINE_NEXT    \ Enable Inline NEXT
  6.  
  7. : ?.INLINE      ( --- )         \ Print state of INLINE_NEXT
  8.                 CR ." NEXT is currently " INLINE_NEXT >REV
  9.                 IF      [ASSEMBLER] INLINEON  [FORTH]
  10.                         ."  INLINE. "
  11.                 ELSE    [ASSEMBLER] INLINEOFF [FORTH]
  12.                         ."  NOT " >NORM ."  INLINE. "
  13.                 THEN    >NORM CR ;
  14. ?.INLINE
  15.  
  16.    256 DP-T !           \ Set Dictionary pointer
  17.      0 DP-X !           \ Set LIST DP
  18.  
  19. HERE   10000 + ' TARGET-ORIGIN >BODY !
  20.  
  21. IN-META
  22.  
  23. : ]]   ]   ;
  24. : [[   [COMPILE] [   ; FORTH IMMEDIATE META
  25.  
  26. FORWARD: DEFINITIONS
  27. FORWARD: [
  28.  
  29. LABEL ORIGIN    JMP HERE 8000 + \ jump to cold start: will be patched
  30.                 JMP HERE 8000 + \ jump to warm start: will be patched
  31.                 END-CODE
  32.  
  33. LABEL DPUSH     PUSH DX         END-CODE
  34. LABEL APUSH     PUSH AX         END-CODE
  35. LABEL >NEXT     LODSW ES:
  36.                 JMP AX          END-CODE
  37.  
  38. \ Create the FORTH vocabulary as the first definition in dictionary.
  39.  
  40. HERE-T ,-Y                      \ valid "previous" CFA for "CREATE
  41.  
  42. HERE-Y HERE-T CNHASH !-Y        \ first entry in >NAME hash table
  43.  
  44. HERE-T DUP 100 + CURRENT-T !    \ harmless
  45.  
  46. HERE-Y VOCABULARY FORTH   FORTH DEFINITIONS
  47.  
  48.                                 \ #THREADS - 1 = 127 the mask.
  49. 0 OVER 2+ !-Y ( link )          \ ASCII F     15 AND = 6
  50.                                 \ ASCII F 5 + 127 AND = 75
  51. 2+ SWAP  >BODY-T
  52. ASCII F 5 +                     \ hash is first char + length
  53. #TTHREADS 1- AND 2*             \ Determine which thread FORTH goes in.
  54. \ ( 12 ) 150
  55. + !-T ( thread 75 )  IN-META
  56.  
  57. VOCABULARY FILES
  58.  
  59. FILES DEFINITIONS
  60.  
  61. \ Create the linked list of files that have been loaded.
  62.  
  63. VARIABLE KERNEL1.SEQ
  64.  
  65. FORTH DEFINITIONS
  66.  
  67. VARIABLE XSEG
  68. VARIABLE YSEG
  69.  
  70. HEX
  71. LABEL ABNORM    MOV AX, # AD26          \ Value to restore in >NEXT
  72.                 MOV >NEXT AX            \ Restore it
  73.                 MOV AX, # E0FF          \ Value to restore in >NEXT + 2
  74.                 MOV >NEXT 2+ AX         \ Restore it
  75.                 XOR AX, AX
  76.                 MOV DS, AX
  77.                 MOV BX, # 471
  78.                 MOV 0 [BX], AL
  79.                 MOV AX, CS
  80.                 MOV DS, AX
  81.                 JMP ORIGIN 3 +  END-CODE
  82.  
  83. LABEL BIOSBK    PUSH AX
  84.                 MOV AL, # E9
  85.                 MOV CS: >NEXT AL
  86.                 MOV AX, # ABNORM >NEXT - 3 -
  87.                 MOV CS: >NEXT 1+ AX
  88.                 POP AX
  89.                 IRET            END-CODE
  90.  
  91. LABEL DOSBK     PUSH AX
  92.                 MOV AH, # 0             \ throw away BREAK KEY
  93.                 INT 16
  94.                 POP AX
  95.                 CLC
  96.                 RETF            END-CODE
  97.  
  98. DECIMAL
  99.  
  100. LABEL NEST              \ JMP = 15 cycles
  101.         SUB RP, # 4
  102.         MOV 2 [RP], ES  \ 19 cycles
  103.         MOV 0 [RP], IP  \ 14 cycles
  104.         MOV DI, AX
  105.         MOV AX, 3 [DI]  \ 18 cycles     \ get relative segment
  106.         ADD AX, XSEG                    \ adjust by base of list space
  107.         MOV ES, AX                      \ move into ES
  108.         SUB IP, IP                      \ clear IP
  109.         NEXT
  110.         END-CODE
  111. META
  112.  
  113. CODE EXIT     ( -- )
  114.         MOV IP, 0 [RP]  \ 13 cycles
  115.         MOV ES, 2 [RP]  \ 18 cycles
  116.         ADD RP, # 4
  117.         NEXT
  118.         END-CODE
  119.  
  120. CODE UNNEST   ( --- )
  121.         MOV IP, 0 [RP]  \ 13 cycles
  122.         MOV ES, 2 [RP]  \ 18 cycles
  123.         ADD RP, # 4
  124.         NEXT            END-CODE
  125.  
  126. LABEL DODOES
  127.         SUB RP, # 4
  128.         MOV 2 [RP], ES  \ 19 cycles
  129.         MOV 0 [RP], IP  \ 14 cycles
  130.         POP DI
  131.         MOV AX, 0 [DI]
  132.         ADD AX, XSEG
  133.         MOV ES, AX
  134.         SUB IP, IP
  135.         NEXT            END-CODE
  136.  
  137. VARIABLE UP
  138.  
  139. LABEL DOCONSTANT
  140.         POP BX
  141.         PUSH 0 [BX]
  142.         NEXT            END-CODE
  143.  
  144. LABEL DOUSER-VARIABLE
  145.         POP BX
  146.         MOV AX, 0 [BX]
  147.         ADD AX, UP
  148.         1PUSH           END-CODE
  149.  
  150. CODE (LIT)      ( -- n )
  151.                 LODSW ES:       1PUSH           END-CODE
  152.  
  153. T: LITERAL      ( n -- ) [TARGET] (LIT)   ,-X   T;
  154. T: DLITERAL     ( d -- ) [TARGET] (LIT) ,-X   [TARGET] (LIT) ,-X   T;
  155. T: ASCII        ( -- )   [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META]  T;
  156. T: [']          ( -- )   'T >BODY @
  157.                          [[ TRANSITION ]] LITERAL  [META]   T;
  158. : CONSTANT      ( n -- )
  159.                 RECREATE   232 C,-T
  160.                 [[ ASSEMBLER DOCONSTANT ]] LITERAL HERE 2+ - ,-T
  161.                 DUP ,-T   CONSTANT   ;
  162.  
  163. FORWARD: <(;CODE)>
  164. T: DOES>        ( -- )
  165.                 [FORWARD] <(;CODE)> HERE-T ,-X
  166.                 HERE-T  ( DOES-OP ) 232 C,-T
  167.                 [[ ASSEMBLER DODOES ]] LITERAL HERE 2+ - ,-T
  168.                 HERE-X PARAGRAPH-X + DUP DPSEG-X ! SEG-X @ - ,-T
  169.                 DP-X OFF T;
  170.  
  171. : NUMERIC   ( -- )
  172.                 [FORTH] HERE [META] NUMBER   DPL @ 1+
  173.                 IF      [[ TRANSITION ]] DLITERAL [META]
  174.                 ELSE    DROP   [[ TRANSITION ]] LITERAL [META]   THEN  ;
  175.  
  176. : UNDEFINED     ( -- )
  177.                 HERE-X >XREL 0 ,-X
  178.                 IN-FORWARD  [FORTH] CREATE [META] TRANSITION
  179.                 [FORTH] ,   FALSE ,   [META]
  180.                 DOES>   FORWARD-CODE   ;
  181.  
  182. [FORTH] VARIABLE T-IN      META
  183.  
  184. : ]             ( -- )
  185.                 STATE-T ON   IN-TRANSITION
  186.         BEGIN   >IN @ T-IN !
  187.                 BEGIN   BL WORD DUP C@ 0=       \ If nothing in line
  188.                         ?FILLBUFF               \ Optionally refill buffer
  189.                         INLENGTH 0> AND         \ and input buf not empty
  190.                 WHILE   DROP FILLTIB            \ refill the buffer
  191.                 REPEAT  ?UPPERCASE FIND
  192.                 IF      EXECUTE
  193.                 ELSE    COUNT NUMERIC?
  194.                         IF      NUMERIC
  195.                         ELSE    T-IN @ >IN !   UNDEFINED
  196.                         THEN
  197.                 THEN    STATE-T @ 0=
  198.         UNTIL ;
  199.  
  200. T: [   ( -- )   IN-META   STATE-T OFF   T;
  201.  
  202. T: ;   ( -- )   [TARGET] UNNEST   [[ TRANSITION ]] [   T;
  203.  
  204.  : :   ( -- )   TARGET-CREATE   233 C,-T        \ a JUMP instruction
  205.                 [[ ASSEMBLER NEST ]] LITERAL HERE 2+ - ,-T
  206.                 HERE-X PARAGRAPH-X + DUP DPSEG-X !
  207.                 SEG-X @ - ( DUP H. ) ,-T
  208.                 DP-X OFF ] ;                              \ compile body addr
  209.  
  210. ASSEMBLER CLEAR_LABELS META
  211.  
  212. CODE DOBEGIN    ( -- )  \ REALLY A NOOP
  213.                 NEXT    END-CODE
  214.  
  215. CODE DOTHEN     ( -- )  \ REALLY A NOOP
  216.                 NEXT    END-CODE
  217.  
  218. CODE DOAGAIN    ( -- )
  219.                 MOV ES: IP, 0 [IP]
  220.                 NEXT           END-CODE
  221.  
  222. CODE DOREPEAT   ( -- )
  223. LABEL DOREP1    MOV ES: IP, 0 [IP]
  224.                 NEXT           END-CODE
  225.  
  226. CODE ?WHILE     ( f -- )
  227.                 POP AX          OR AX, AX
  228.                 JE DOREP1
  229.                 ADD IP, # 2
  230.                 NEXT            END-CODE
  231.  
  232. CODE ?UNTIL     ( f -- )
  233.                 POP AX          OR AX, AX
  234.                 JE DOREP1
  235.                 ADD IP, # 2
  236.                 NEXT            END-CODE
  237.  
  238. CODE BRANCH     ( -- )
  239. LABEL BRAN1     MOV ES: IP, 0 [IP]
  240.                 NEXT            END-CODE
  241.  
  242. CODE ?BRANCH    ( f -- )
  243.                 POP AX          OR AX, AX
  244.                 JE BRAN1
  245.                 ADD IP, # 2
  246.                 NEXT            END-CODE
  247.  
  248. T: BEGIN        [TARGET] DOBEGIN X?<MARK   T;
  249. T: AGAIN        [TARGET] DOAGAIN X?<RESOLVE   T;
  250. T: UNTIL        [TARGET] ?UNTIL  X?<RESOLVE   T;
  251. T: IF           [TARGET] ?BRANCH X?>MARK      T;
  252. T: THEN         [TARGET] DOTHEN  X?>RESOLVE    T;
  253. T: ELSE         [TARGET] BRANCH  X?>MARK   2SWAP X?>RESOLVE   T;
  254. T: WHILE        [TARGET] ?WHILE  X?>MARK   T;
  255. T: REPEAT       2SWAP [TARGET] DOREPEAT X?<RESOLVE X?>RESOLVE T;
  256.  
  257. LABEL LOOPEXIT  ( --- )
  258.                 ADD RP, # 6     ADD IP, # 2
  259.                 NEXT            END-CODE
  260.  
  261. CODE (LOOP)     ( -- )
  262.                 INC 0 [RP] WORD
  263.                 JO LOOPEXIT
  264.                 MOV ES: IP, 0 [IP]
  265.                 NEXT            END-CODE
  266.  
  267. CODE (+LOOP)    ( n -- )
  268.                 AX POP          ADD 0 [RP], AX
  269.                 JO LOOPEXIT     MOV ES: IP, 0 [IP]
  270.                 NEXT            END-CODE
  271.  
  272. HEX
  273. CODE (DO)       ( l i -- )
  274.                 POP AX          POP BX
  275. LABEL PDO1      SUB RP, # 2
  276.                 MOV ES: DX, 0 [IP]
  277.                 MOV 0 [RP], DX
  278.                 ADD IP, # 2
  279.                 ADD BX, # 8000
  280.                 SUB RP, # 2
  281.                 MOV 0 [RP], BX  SUB AX, BX
  282.                 SUB RP, # 2
  283.                 MOV 0 [RP], AX
  284.                 NEXT            END-CODE
  285. DECIMAL
  286.  
  287. CODE (?DO)      ( l i -- )
  288.                 POP AX          POP BX
  289.                 CMP BX, AX
  290.                 JNE PDO1        MOV ES: IP, 0 [IP]
  291.                 NEXT            END-CODE
  292.  
  293.  
  294. CODE (OF)       ( n1 n2 -- n1 )  ( or )  ( n1 n1 -- )
  295.                 POP AX          XCHG SP, RP     CMP AX, 0 [RP]
  296.         0= IF
  297.                 XCHG RP, SP     POP AX
  298.                 ADD IP, # 2     NEXT
  299.         ELSE
  300.                 XCHG RP, SP     MOV ES: IP, 0 [IP]
  301.                 NEXT
  302.         THEN
  303.                 END-CODE
  304.  
  305. CODE BOUNDS     ( n1 n2 --- n3 n4 )
  306.                 POP DX          POP AX          ADD DX, AX
  307.                 2PUSH           END-CODE
  308.  
  309. T: ?DO          [TARGET] (?DO)   X?>MARK   T;
  310. T: DO           [TARGET] (DO)    X?>MARK   T;
  311. T: LOOP         [TARGET] (LOOP)    2DUP 2+   X?<RESOLVE   X?>RESOLVE   T;
  312. T: +LOOP        [TARGET] (+LOOP)   2DUP 2+   X?<RESOLVE   X?>RESOLVE   T;
  313.  
  314. ASSEMBLER >NEXT META CONSTANT >NEXT
  315.  
  316. CODE EXECUTE    ( cfa -- )
  317.                 POP AX          JMP AX          END-CODE
  318.  
  319. CODE PERFORM    ( addr-of-cfa -- )
  320. LABEL DODEFER   POP BX          MOV AX, 0 [BX]
  321.                 JMP AX          END-CODE
  322.  
  323. CODE EXEC:      ( N1 -- )
  324.                 POP BX
  325.                 SHL BX, # 1
  326.                 ADD BX, IP
  327.                 MOV ES: AX, 0 [BX]
  328.                 MOV IP, 0 [RP]  \ 13 cycles
  329.                 MOV ES, 2 [RP]  \ 18 cycles
  330.                 ADD RP, # 4
  331.                 JMP AX          END-CODE
  332.  
  333. LABEL DOUSER-DEFER
  334.                 POP BX          MOV BX, 0 [BX]
  335.                 ADD BX, UP      MOV AX, 0 [BX]
  336.                 JMP AX          END-CODE
  337.  
  338. CODE GO         RET             END-CODE        ( ADDR --- )
  339.  
  340. CODE NOOP       NEXT            END-CODE
  341.  
  342. CODE PAUSE      NOOP                            \ Gets patched
  343.                 NOOP
  344.                 NOOP
  345.                 NEXT            END-CODE
  346.  
  347. DECIMAL
  348.  
  349. CODE I ( -- n ) MOV AX, 0 [RP]  ADD AX, 2 [RP]
  350.                 1PUSH           END-CODE
  351.  
  352. CODE J ( -- n ) MOV AX, 6 [RP]  ADD AX, 8 [RP]
  353.                 1PUSH           END-CODE
  354.  
  355. CODE K ( -- n ) MOV AX, 12 [RP] ADD AX, 14 [RP]
  356.                 1PUSH           END-CODE
  357.  
  358. CODE (LEAVE)    ( -- )
  359. LABEL PLEAVE    ADD RP, # 4     MOV IP, 0 [RP]
  360.                 ADD RP, # 2
  361.                 NEXT            END-CODE
  362.  
  363. CODE (?LEAVE)   ( f -- )
  364.                 POP AX          OR AX, AX       JNE PLEAVE
  365.                 NEXT            END-CODE
  366.  
  367. T: LEAVE        [TARGET] (LEAVE)   T;
  368. T: ?LEAVE       [TARGET] (?LEAVE)  T;
  369.  
  370. CODE @          ( addr -- n )
  371.                 POP BX          PUSH 0 [BX]
  372.                 NEXT            END-CODE
  373.  
  374. CODE !          ( n addr -- )
  375.                 POP BX          POP 0 [BX]
  376.                 NEXT            END-CODE
  377.  
  378. CODE C@         ( addr -- char )
  379.                 POP BX          SUB AX, AX      MOV AL, 0 [BX]
  380.                 1PUSH           END-CODE
  381.  
  382. CODE C!         ( char addr -- )
  383.                 POP BX          POP AX          MOV 0 [BX], AL
  384.                 NEXT            END-CODE
  385.  
  386. CODE CMOVE      (  from to count -- )
  387.                 CLD             MOV BX, IP      MOV AX, DS
  388.                 POP CX          POP DI          POP IP
  389.                 PUSH ES         MOV ES, AX
  390.                 REPNZ           MOVSB
  391.                 MOV IP, BX      POP ES
  392.                 NEXT            END-CODE
  393.  
  394. CODE CMOVE>     ( from to count -- )
  395.                 STD             MOV BX, IP      MOV AX, DS
  396.                 POP CX          DEC CX
  397.                 POP DI          POP IP
  398.                 ADD DI, CX      ADD IP, CX      INC CX
  399.                 PUSH ES         MOV ES, AX
  400.                 REPNZ           MOVSB
  401.                 MOV IP, BX      CLD             POP ES
  402.                 NEXT            END-CODE
  403.  
  404. CODE PLACE      ( from cnt to -- )
  405.                 POP BX          POP AX          MOV 0 [BX], AL
  406.                 INC BX          PUSH BX         PUSH AX
  407.                 CLD             MOV BX, IP      MOV AX, DS
  408.                 POP CX          POP DI          POP IP
  409.                 PUSH ES         MOV ES, AX
  410.                 REPNZ           MOVSB
  411.                 MOV IP, BX      POP ES
  412.                 NEXT            END-CODE
  413.  
  414. DECIMAL
  415.  
  416. CODE SP@        ( -- n )
  417.                 MOV AX, SP      1PUSH           END-CODE
  418.  
  419. CODE SP!        ( n -- )
  420.                 POP SP          NEXT            END-CODE
  421.  
  422. CODE RP@        ( -- addr )
  423.                 MOV AX, RP      1PUSH           END-CODE
  424.  
  425. CODE RP!        ( n -- )
  426.                 POP RP          NEXT            END-CODE
  427.  
  428. CODE DROP       ( n1 -- )
  429.                 POP AX          NEXT            END-CODE
  430.  
  431. CODE DUP        ( n1 -- n1 n1 )
  432.                 POP AX          PUSH AX
  433.                 1PUSH           END-CODE
  434.  
  435. CODE SWAP       ( n1 n2 -- n2 n1 )
  436.                 POP DX          POP AX
  437.                 2PUSH           END-CODE
  438.  
  439. CODE OVER       ( n1 n2 -- n1 n2 n1 )
  440.                 POP DX          POP AX
  441.                 PUSH AX         2PUSH           END-CODE
  442.  
  443. CODE TUCK       ( n1 n2 -- n2 n1 n2 )
  444.                 POP AX          POP DX
  445.                 PUSH AX         2PUSH           END-CODE
  446.  
  447. CODE NIP        ( n1 n2 -- n2 )
  448.                 POP AX          POP DX
  449.                 1PUSH           END-CODE
  450.  
  451. CODE ROT        ( n1 n2 n3 --- n2 n3 n1 )
  452.                 POP DX          POP BX          POP AX
  453.                 PUSH BX         2PUSH           END-CODE
  454.  
  455. CODE -ROT       ( n1 n2 n3 --- n3 n1 n2 )
  456.                 POP BX          POP AX          POP DX
  457.                 PUSH BX         2PUSH           END-CODE
  458.  
  459. CODE FLIP       ( n1 -- n2 )
  460.                 POP AX          XCHG AL, AH
  461.                 1PUSH           END-CODE
  462.  
  463. CODE ?DUP       ( n1 -- [n1] n1 )
  464.                 POP AX          CMP AX, # 0
  465.             0<> IF
  466.                 PUSH AX
  467.             THEN
  468.                 1PUSH           END-CODE
  469.  
  470. CODE R>         ( -- n )
  471.                 MOV AX, 0 [RP]  ADD RP, # 2
  472.                 1PUSH           END-CODE
  473.  
  474. CODE R>DROP     ( --- )
  475.                 ADD RP, # 2
  476.                 NEXT            END-CODE
  477.  
  478. CODE >R         ( n -- )
  479.                 POP AX          SUB RP, # 2
  480.                 MOV 0 [RP], AX
  481.                 NEXT            END-CODE
  482.  
  483. CODE 2R>        ( -- n )
  484.                 MOV DX, 0 [RP]
  485.                 MOV AX, 2 [RP]
  486.                 ADD RP, # 4
  487.                 2PUSH           END-CODE
  488.  
  489. CODE 2>R        ( n -- )
  490.                 POP AX
  491.                 MOV -2 [RP], AX
  492.                 POP AX
  493.                 MOV -4 [RP], AX
  494.                 SUB RP, # 4
  495.                 NEXT            END-CODE
  496.  
  497. CODE R@         ( -- n )
  498.                 MOV AX, 0 [RP]
  499.                 1PUSH           END-CODE
  500.  
  501. CODE 2R@        ( -- n )
  502.                 MOV DX, 0 [RP]
  503.                 MOV AX, 2 [RP]
  504.                 2PUSH           END-CODE
  505.  
  506. CODE 2R@SWAP    ( -- n )
  507.                 MOV DX, 2 [RP]
  508.                 MOV AX, 0 [RP]
  509.                 2PUSH           END-CODE
  510.  
  511. CODE PICK       ( nm ... n2 n1 k -- nm ... n2 n1 nk )
  512.                 POP BX          SHL BX, # 1     ADD BX, SP
  513.                 MOV AX, 0 [BX]  1PUSH           END-CODE
  514.  
  515. CODE AND        ( n1 n2 -- n3 )
  516.                 POP BX          POP AX          AND AX, BX
  517.                 1PUSH           END-CODE
  518.  
  519. CODE OR         ( n1 n2 -- n3 )
  520.                 POP BX          POP AX          OR AX, BX
  521.                 1PUSH           END-CODE
  522.  
  523. CODE XOR        ( n1 n2 -- n3 )
  524.                 POP BX          POP AX          XOR AX, BX
  525.                 1PUSH           END-CODE
  526.  
  527. CODE NOT        ( n -- n' )
  528.                 POP AX          NOT AX
  529.                 1PUSH           END-CODE
  530.  
  531. -1 CONSTANT TRUE
  532.  0 CONSTANT FALSE
  533.  
  534. CODE CSET       ( b addr -- )
  535.                 POP BX          POP AX          OR 0 [BX], AL
  536.                 NEXT            END-CODE
  537.  
  538. CODE CRESET     ( b addr -- )
  539.                 POP BX          POP AX
  540.                 NOT AX          AND 0 [BX], AL
  541.                 NEXT            END-CODE
  542.  
  543. CODE CTOGGLE    ( b addr -- )
  544.                 POP BX          POP AX          XOR 0 [BX], AL
  545.                 NEXT            END-CODE
  546.  
  547. CODE ON         ( addr -- )
  548.                 POP BX          MOV 0 [BX], # TRUE WORD
  549.                 NEXT            END-CODE
  550.  
  551. CODE OFF        ( addr -- )
  552.                 POP BX          MOV 0 [BX], # FALSE WORD
  553.                 NEXT            END-CODE
  554.  
  555. CODE -1!        ( addr -- )
  556.                 POP BX          MOV 0 [BX], # TRUE WORD
  557.                 NEXT            END-CODE
  558.  
  559. CODE 0!         ( addr -- )
  560.                 POP BX          MOV 0 [BX], # FALSE WORD
  561.                 NEXT            END-CODE
  562.  
  563. CODE INCR       ( A1 --- )
  564.                 POP BX          INC 0 [BX] WORD
  565.                 NEXT            END-CODE
  566.  
  567. CODE DECR       ( A1 --- )
  568.                 POP BX          DEC 0 [BX] WORD
  569.                 NEXT            END-CODE
  570.  
  571. CODE +          ( n1 n2 -- sum )
  572.                 POP BX          POP AX          ADD AX, BX
  573.                 1PUSH           END-CODE
  574.  
  575. CODE NEGATE     ( n -- n' )
  576.                 POP AX          NEG AX
  577.                 1PUSH           END-CODE
  578.  
  579. CODE -          ( n1 n2 -- n1-n2 )
  580.                 POP BX          POP AX          SUB AX, BX
  581.                 1PUSH           END-CODE
  582.  
  583. CODE ABS        ( n -- n )
  584.                 POP AX
  585.                 CWD
  586.                 XOR AX, DX
  587.                 SUB AX, DX
  588.                 1PUSH
  589.                 END-CODE
  590.  
  591. CODE 2+!        ( d addr -- )
  592.                 POP BX          POP AX          POP DX
  593.                 ADD 0 [BX], DX  ADC 2 [BX], AX
  594.                 NEXT            END-CODE
  595.  
  596. CODE +!         ( n addr -- )
  597.                 POP BX          POP AX          ADD 0 [BX], AX
  598.                 NEXT            END-CODE
  599.  
  600. CODE C+!        ( n addr -- )
  601.                 POP BX          POP AX          ADD 0 [BX], AL
  602.                 NEXT            END-CODE
  603.  
  604.  
  605. \ Since the 8086 has a seperate IO path, we define a Forth
  606. \ interface to it.  Use P@ and P! to read or write directly to
  607. \ the 8086 IO ports.
  608.  
  609. CODE PC@        ( port# -- n )
  610.                 POP DX          IN AL, DX       SUB AH, AH
  611.                 PUSH AX         NEXT            END-CODE
  612.  
  613. CODE P@         ( port# -- n )
  614.                 POP DX          IN AX, DX       PUSH AX
  615.                 NEXT            END-CODE
  616.  
  617. CODE PC!        ( n port# -- )
  618.                 POP DX          POP AX          OUT DX, AL
  619.                 NEXT            END-CODE
  620.  
  621. CODE P!         ( n port# -- )
  622.                 POP DX          POP AX          OUT DX, AX
  623.                 NEXT            END-CODE
  624.  
  625.                 \ read drive path into addr, null terminated.
  626. CODE PDOS       ( addr drive --- f1 ) \ RETURN PATH OF DRIVE
  627.                 pop dx          pop ax
  628.                 push si         mov si, ax
  629.                 mov ah, # 71    int 33
  630.              u< if
  631.                 mov al, # 1
  632.              else
  633.                 mov al, # 0
  634.              then
  635.                 sub ah, ah      pop si
  636.                 1push           end-code
  637.  
  638. #TTHREADS CONSTANT #THREADS
  639.  
  640. CODE 2*         ( n -- 2*n )
  641.                 POP AX          SHL AX, # 1
  642.                 1PUSH           END-CODE
  643.  
  644. CODE 2/         ( n -- n/2 )
  645.                 POP AX          SAR AX, # 1
  646.                 1PUSH           END-CODE
  647.  
  648. CODE U2/        ( u -- u/2 )
  649.                 POP AX          SHR AX, # 1
  650.                 1PUSH           END-CODE
  651.  
  652. CODE U16/       ( u -- u/16 )
  653.                 POP AX
  654.                 SHR AX, # 1     SHR AX, # 1
  655.                 SHR AX, # 1     SHR AX, # 1
  656.                 1PUSH           END-CODE
  657.  
  658. CODE 8*         ( n -- 8*n )
  659.                 POP AX          SHL AX, # 1
  660.                 SHL AX, # 1     SHL AX, # 1
  661.                 1PUSH           END-CODE
  662.  
  663.                 ( n1 --- n2 )
  664. CODE 1+         POP AX          INC AX
  665.                 1PUSH           END-CODE
  666.  
  667. CODE 2+         POP AX          ADD AX, # 2
  668.                 1PUSH           END-CODE
  669.  
  670. CODE 1-         POP AX          DEC AX
  671.                 1PUSH           END-CODE
  672.  
  673. CODE 2-         POP AX          SUB AX, # 2
  674.                 1PUSH           END-CODE
  675.  
  676. CODE UM*        ( n1 n2 -- d )
  677.                 POP AX          POP BX          MUL BX
  678.                 XCHG DX, AX     2PUSH           END-CODE
  679.  
  680. CODE *          ( N1 N2 -- N3 )
  681.                 POP AX          POP BX          MUL BX
  682.                 1PUSH           END-CODE
  683.  
  684. : U*D           ( n1 n2 -- d )  UM*   ;
  685.  
  686. CODE UM/MOD     ( d1 n1 -- Remainder Quotient )
  687.                 POP BX          POP DX          POP AX
  688.                 CMP DX, BX
  689.             U>=  ( divide by zero? )
  690.             IF
  691.                 MOV AX, # -1    MOV DX, AX      2PUSH
  692.             THEN
  693.                 DIV BX          2PUSH           END-CODE
  694.  
  695. LABEL YES       MOV AX, # TRUE  1PUSH           END-CODE
  696.  
  697. CODE 0=         ( n -- f )
  698.                 POP AX          OR AX, AX
  699.                 JE YES
  700.                 SUB AX, AX      1PUSH           END-CODE
  701.  
  702. CODE 0<         ( n -- f )
  703.                 POP AX          OR AX, AX
  704.                 JS YES
  705.                 SUB AX, AX      1PUSH           END-CODE
  706.  
  707. CODE 0>         ( n -- f )
  708.                 POP AX          OR AX, AX
  709.                 JG YES
  710.                 SUB AX, AX      1PUSH           END-CODE
  711.  
  712. CODE 0<>        ( n -- f )
  713.                 POP AX          OR AX, AX
  714.                 JNE YES
  715.                 SUB AX, AX      1PUSH           END-CODE
  716.  
  717. CODE =          ( n1 n2 -- f )
  718.                 POP AX          POP BX          CMP BX, AX
  719.                 JE YES
  720.                 SUB AX, AX      1PUSH           END-CODE
  721.  
  722. CODE <>         ( n1 n2 -- f )
  723.                 POP AX          POP BX          CMP BX, AX
  724.                 JNE YES
  725.                 SUB AX, AX      1PUSH           END-CODE
  726.  
  727. \ : <>            ( n1 n2 -- f )  = NOT   ;
  728.  
  729. : ?NEGATE       ( n1 n2 -- n3 ) 0< IF    NEGATE   THEN   ;
  730.  
  731. CODE   U<       ( n1 n2 -- f )
  732.                 POP AX          POP BX          CMP BX, AX
  733.                 JB YES
  734.                 SUB AX, AX      1PUSH           END-CODE
  735.  
  736. CODE   U>       ( n1 n2 -- f )
  737.                 POP AX          POP BX          CMP AX, BX
  738.                 JB YES
  739.                 SUB AX, AX      1PUSH           END-CODE
  740.  
  741. CODE <          ( n1 n2 -- f )
  742.                 POP AX          POP BX          CMP BX, AX
  743.                 JL YES
  744.                 SUB AX, AX      1PUSH           END-CODE
  745.  
  746. CODE >          ( n1 n2 -- f )
  747.                 POP AX          POP BX          CMP BX, AX
  748.                 JG YES
  749.                 SUB AX, AX
  750. LABEL PUSH1     1PUSH           END-CODE
  751.  
  752. CODE MIN        POP AX          POP BX          CMP BX, AX
  753.                 JG PUSH1
  754. LABEL MIN1      PUSH BX         NEXT            END-CODE
  755.  
  756. CODE MAX        POP AX          POP BX          CMP BX, AX
  757.                 JG MIN1
  758.                 1PUSH           END-CODE
  759.  
  760. : BETWEEN       ( n1 min max -- f )     >R  OVER > SWAP R> > OR NOT ;
  761. : WITHIN        ( n1 min max -- f )     1- BETWEEN  ;
  762.  
  763. CODE 2@         ( addr -- d )
  764.                 POP BX          MOV AX, 0 [BX]  MOV DX, 2 [BX]
  765.                 2PUSH           END-CODE
  766.  
  767. CODE 2!         ( d addr -- )
  768.                 POP BX          POP 0 [BX]      POP 2 [BX]
  769.                 NEXT            END-CODE
  770.  
  771. CODE 2DROP      ( d -- )
  772.                 POP AX          POP AX
  773.                 NEXT            END-CODE
  774.  
  775. CODE 3DROP      ( d -- )
  776.                 POP AX          POP AX          POP AX
  777.                 NEXT            END-CODE
  778.  
  779. CODE 2DUP       ( d -- d d )
  780.                 POP AX          POP DX
  781.                 PUSH DX         PUSH AX
  782.                 2PUSH           END-CODE
  783.  
  784. CODE 3DUP       ( d -- d d )
  785.                 POP AX          POP DX          POP BX
  786.                 PUSH BX         PUSH DX         PUSH AX
  787.                 PUSH BX         PUSH DX         PUSH AX
  788.                 NEXT            END-CODE
  789.  
  790. CODE 2SWAP      ( d1 d2 -- d2 d1 )
  791.                 POP CX          POP BX
  792.                 POP AX          POP DX
  793.                 PUSH BX         PUSH CX
  794.                 2PUSH           END-CODE
  795.  
  796. CODE 2OVER      ( d2 d2 -- d1 d2 d1 )
  797.                 POP CX          POP BX
  798.                 POP AX          POP DX
  799.                 PUSH DX         PUSH AX
  800.                 PUSH BX         PUSH CX
  801.                 2PUSH           END-CODE
  802.  
  803. CODE D+         ( d1 d2 -- dsum )
  804.                 POP AX          POP DX
  805.                 POP BX          POP CX
  806.                 ADD DX, CX      ADC AX, BX
  807.                 2PUSH           END-CODE
  808.  
  809. CODE DNEGATE    ( d# -- d#' )
  810.                 POP AX
  811. LABEL DNEG1     POP DX
  812.                 NEG AX
  813.                 NEG DX
  814.                 SBB AX, # 0
  815.                 2PUSH
  816.                 END-CODE
  817.  
  818. CODE   S>D      ( n -- d )
  819.                 POP AX          CWD             XCHG DX, AX
  820.                 2PUSH           END-CODE
  821.  
  822. CODE DABS       ( d# -- d# )
  823.                 POP AX
  824.                 OR AX, AX
  825.                 JS DNEG1
  826.                 1PUSH           END-CODE
  827.  
  828. CODE D2*        ( d -- d*2 )
  829.                 POP AX          POP DX
  830.                 SHL DX, # 1     RCL AX, # 1
  831.                 2PUSH           END-CODE
  832.  
  833. CODE D2/        ( d -- d/2 )
  834.                 POP AX          POP DX
  835.                 SAR AX, # 1     RCR DX, # 1
  836.                 2PUSH           END-CODE
  837.  
  838. : D-            ( d1 d2 -- d3 ) DNEGATE D+   ;
  839.  
  840. : ?DNEGATE      ( d1 n -- d2 )  0< IF   DNEGATE   THEN   ;
  841.  
  842. : D0=           ( d -- f )      OR 0= ;
  843.  
  844. : D=            ( d1 d2 -- f )  D-  D0=  ;
  845.  
  846. : DU<           ( ud1 ud2 -- f )
  847.                 ROT SWAP 2DUP U<
  848.                 IF      2DROP 2DROP TRUE
  849.                 ELSE    <> IF   2DROP FALSE  ELSE  U<  THEN
  850.                 THEN  ;
  851.  
  852. : D<            ( d1 d2 -- f )
  853.                 2 PICK OVER =
  854.                 IF      DU<
  855.                 ELSE  NIP ROT DROP <  THEN  ;
  856.  
  857. : D>            ( d1 d2 -- f )  2SWAP D<   ;
  858.  
  859. : 4DUP          ( a b c d -- a b c d a b c d )  2OVER 2OVER   ;
  860.  
  861. : DMIN          ( d1 d2 -- d3 ) 4DUP D> IF  2SWAP  THEN 2DROP ;
  862.  
  863. : DMAX          ( d1 d2 -- d3 ) 4DUP D< IF  2SWAP  THEN  2DROP ;
  864.  
  865. : *D            ( n1 n2 -- d# )
  866.                 2DUP  XOR  >R  ABS  SWAP  ABS  UM*  R>  ?DNEGATE  ;
  867.  
  868. : M/MOD         ( d# n1 -- rem quot )
  869.                 ?DUP
  870.                 IF  DUP >R  2DUP XOR >R  >R DABS R@ ABS  UM/MOD
  871.                         SWAP R> ?NEGATE
  872.                         SWAP R> 0<
  873.                         IF  NEGATE OVER
  874.                                 IF  1- R@ ROT - SWAP  THEN
  875.                         THEN    r>drop
  876.                 THEN  ;
  877.  
  878. : MU/MOD        ( d# n1 -- rem d#quot )
  879.                 >R  0  R@  UM/MOD  R>  SWAP  >R  UM/MOD  R>   ;
  880.  
  881. CODE /          ( NUM DEN --- QUOT )
  882.                 POP BX          POP AX          CWD
  883.                 MOV CX, BX      XOR CX, DX
  884.             0>= IF                              \ POSITIVE QUOTIENT CASE
  885.                 IDIV BX         1PUSH
  886.             THEN
  887.                 IDIV BX         OR DX, DX
  888.             0<> IF
  889.                 DEC AX
  890.             THEN
  891.                 1PUSH           END-CODE
  892.  
  893. CODE /MOD       ( NUM DEN --- REM QUOT )
  894.                 POP BX          POP AX          CWD
  895.                 MOV CX, BX      XOR CX, DX
  896.             0>= IF
  897.                 IDIV BX         2PUSH
  898.             THEN
  899.                 IDIV BX         OR DX, DX
  900.             0<> IF
  901.                 ADD DX, BX      DEC AX
  902.            THEN
  903.                 2PUSH           END-CODE
  904.  
  905. : MOD           ( n1 n2 -- rem ) /MOD  DROP  ;
  906.  
  907. CODE */MOD      ( N1 N2 N3 --- REM QUOT )
  908.                 POP BX          POP AX          POP CX
  909.                 IMUL CX         MOV CX, BX      XOR CX, DX
  910.             0>= IF
  911.                 IDIV BX         2PUSH
  912.             THEN
  913.                 IDIV BX         OR DX, DX
  914.             0<> IF
  915.                 ADD DX, BX      DEC AX
  916.             THEN
  917.                 2PUSH           END-CODE
  918.  
  919. : */            ( n1 n2 n3 -- n1*n2/n3 ) */MOD  NIP  ;
  920.  
  921. : ROLL          ( n1 n2 .. nk n -- wierd )
  922.                 >R R@ PICK   SP@ DUP 2+   R> 1+ 2* CMOVE>  DROP  ;
  923.  
  924. : 2ROT          ( a b c d e f - c d e f a b )   5 ROLL  5 ROLL  ;
  925.  
  926.  
  927.